home *** CD-ROM | disk | FTP | other *** search
/ Skunkware 98 / Skunkware 98.iso / src / interp / perl-5.003.tar.gz / perl-5.003.tar / perl-5.003 / pod / pod2html.PL < prev    next >
Perl Script  |  1996-03-25  |  16KB  |  550 lines
  1. #!/usr/local/bin/perl
  2.  
  3. use Config;
  4. use File::Basename qw(&basename &dirname);
  5.  
  6. # List explicitly here the variables you want Configure to
  7. # generate.  Metaconfig only looks for shell variables, so you
  8. # have to mention them as if they were shell variables, not
  9. # %Config entries.  Thus you write
  10. #  $startperl
  11. # to ensure Configure will look for $Config{startperl}.
  12.  
  13. # This forces PL files to create target in same directory as PL file.
  14. # This is so that make depend always knows where to find PL derivatives.
  15. chdir(dirname($0));
  16. ($file = basename($0)) =~ s/\.PL$//;
  17. $file =~ s/\.pl$//
  18.     if ($^O eq 'VMS' or $^O eq 'os2');  # "case-forgiving"
  19.  
  20. open OUT,">$file" or die "Can't create $file: $!";
  21.  
  22. print "Extracting $file (with variable substitutions)\n";
  23.  
  24. # In this section, perl variables will be expanded during extraction.
  25. # You can use $Config{...} to use Configure variables.
  26.  
  27. print OUT <<"!GROK!THIS!";
  28. $Config{'startperl'}
  29. !GROK!THIS!
  30.  
  31. # In the following, perl variables are not expanded during extraction.
  32.  
  33. print OUT <<'!NO!SUBS!';
  34. eval 'exec perl -S $0 ${1+"$@"}'
  35.         if $running_under_some_shell;
  36. #
  37. # pod2html - convert pod format to html
  38. # Version 1.15
  39. # usage: pod2html [podfiles]
  40. # Will read the cwd and parse all files with .pod extension
  41. # if no arguments are given on the command line.
  42. #
  43. # Many helps, suggestions, and fixes from the perl5 porters, and all over.
  44. # Bill Middleton - wjm@metronet.com
  45. #
  46. # Please send patches/fixes/features to me
  47. #
  48. #
  49. # 
  50. *RS = */;
  51. *ERRNO = *!;
  52.  
  53. ################################################################################
  54. # Invoke with various levels of debugging possible
  55. ################################################################################
  56. while ($ARGV[0] =~ /^-d(.*)/) {
  57.     shift;
  58.     $Debug{ lc($1 || shift) }++;
  59. }
  60.  
  61. # ck for podnames on command line
  62. while ($ARGV[0]) {
  63.     push(@Pods,shift);
  64. }
  65.  
  66. ################################################################################
  67. # CONFIGURE
  68. #
  69. # The beginning of the url for the anchors to the other sections.
  70. # Edit $type to suit.  It's configured for relative url's now.
  71. # Other possibilities are:
  72. # $type = '<A HREF="file://localhost/usr/local/htmldir/'; # file url
  73. # $type = '<A HREF="http://www.bozo.com/perl/manual/html/' # server
  74. #
  75. ################################################################################
  76.  
  77. $type = '<A HREF="';        
  78. $dir = ".";             # location of pods
  79.  
  80. # look in these pods for things not found within the current pod
  81. # be careful tho, namespace collisions cause stupid links
  82.  
  83. @inclusions = qw[
  84.      perlfunc perlvar perlrun perlop 
  85. ];
  86. ################################################################################
  87. # END CONFIGURE
  88. ################################################################################
  89.  
  90. $A = {};  # The beginning of all things
  91.  
  92. unless (@Pods) {
  93.     opendir(DIR,$dir)  or  die "Can't opendir $dir: $ERRNO";
  94.     @Pods = grep(/\.pod$/,readdir(DIR));
  95.     closedir(DIR) or die "Can't closedir $dir: $ERRNO";
  96. }
  97. @Pods or die "aak, expected pods";
  98.  
  99. # loop twice through the pods, first to learn the links, then to produce html
  100. for $count (0,1) {
  101.     print STTDER "Scanning pods...\n" unless $count;
  102.     foreach $podfh ( @Pods ) {
  103.     ($pod = $podfh) =~ s/\.pod$//;
  104.     Debug("files", "opening 2 $podfh" );
  105.     print "Creating $pod.html from $podfh\n" if $count;
  106.     $RS = "\n=";         # grok pods by item (Nonstandard but effecient)
  107.     open($podfh,"<".$podfh)  || die "can't open $podfh: $ERRNO";
  108.     @all = <$podfh>;
  109.     close($podfh);
  110.     $RS = "\n";
  111.  
  112.     $all[0] =~ s/^=//;
  113.     for (@all) { s/=$// }
  114.     $Podnames{$pod} = 1;
  115.     $in_list = 0;
  116.     $html = $pod.".html";
  117.     if ($count) {              # give us a html and rcs header
  118.         open(HTML,">$html") || die "can't create $html: $ERRNO";
  119.         print HTML '<!-- $Id$ -->',"\n",'<HTML><HEAD>',"\n";
  120.         print HTML "<CENTER>" unless $NO_NS;
  121.         print HTML "<TITLE>$pod</TITLE>\n</HEAD>\n<BODY>";
  122.         print HTML "</CENTER>" unless $NO_NS;
  123.     }
  124.     for ($i = 0; $i <= $#all; $i++) {       # decide what to do with each chunk
  125.         $all[$i] =~ /^(\w+)\s*(.*)\n?([^\0]*)$/ ;
  126.         ($cmd, $title, $rest) = ($1,$2,$3);
  127.         if ($cmd eq "item") {
  128.         if ($count ) { # producing html
  129.             do_list("over",$all[$i],\$in_list,\$depth) unless $depth;
  130.             do_item($title,$rest,$in_list);
  131.         }
  132.         else {  
  133.             # scan item
  134.             scan_thing("item",$title,$pod);
  135.         }
  136.         }
  137.         elsif ($cmd =~ /^head([12])/) {
  138.         $num = $1;
  139.         if ($count) { # producing html
  140.             do_hdr($num,$title,$rest,$depth);
  141.         }
  142.         else {
  143.             # header scan
  144.             scan_thing($cmd,$title,$pod); # skip head1
  145.         }
  146.         }
  147.         elsif ($cmd =~ /^over/) {
  148.         $count and $depth and do_list("over",$all[$i+1],\$in_list,\$depth);
  149.         }
  150.         elsif ($cmd =~ /^back/) {
  151.         if ($count) {  # producing html
  152.             ($depth) or next; # just skip it
  153.             do_list("back",$all[$i+1],\$in_list,\$depth);
  154.             do_rest("$title.$rest");
  155.         }
  156.         }
  157.         elsif ($cmd =~ /^cut/) {
  158.         next;
  159.         }
  160.             elsif ($cmd =~ /^for/) {  # experimental pragma html
  161.                 if ($count) {  # producing html
  162.                     if ($title =~ s/^html//) {
  163.                         $in_html =1;
  164.                         do_rest("$title.$rest");
  165.                     }
  166.                 }
  167.             }
  168.             elsif ($cmd =~ /^begin/) {  # experimental pragma html
  169.                 if ($count) {  # producing html
  170.                     if ($title =~ s/^html//) {
  171.                         print HTML $title,"\n",$rest;
  172.                     }
  173.                     elsif ($title =~ /^end/) {
  174.                         next;
  175.                     }
  176.                 }
  177.             }
  178.         elsif ($Debug{"misc"}) { 
  179.         warn("unrecognized header: $cmd");
  180.         }
  181.     }
  182.         # close open lists without '=back' stmts
  183.     if ($count) {  # producing html
  184.         while ($depth) {
  185.          do_list("back",$all[$i+1],\$in_list,\$depth);
  186.         }
  187.         print HTML "\n</BODY>\n</HTML>\n";
  188.     }
  189.     }
  190. }
  191.  
  192. sub do_list{   # setup a list type, depending on some grok logic
  193.     my($which,$next_one,$list_type,$depth) = @_;
  194.     my($key);
  195.     if ($which eq "over") {
  196.     unless ($next_one =~ /^item\s+(.*)/) {
  197.         warn "Bad list, $1\n" if $Debug{"misc"};
  198.     }
  199.     $key = $1;
  200.  
  201.     if      ($key =~ /^1\.?/) {
  202.         $$list_type = "OL";
  203.     } elsif ($key =~ /\*\s*$/) {
  204.         $$list_type = "UL";
  205.     } elsif ($key =~ /\*?\s*\w/) {
  206.         $$list_type = "DL";
  207.     } else {
  208.         warn "unknown list type for item $key" if $Debug{"misc"};
  209.     }
  210.  
  211.     print HTML qq{\n};
  212.     print HTML $$list_type eq 'DL' ? qq{<DL COMPACT>} : qq{<$$list_type>};
  213.     $$depth++;
  214.     }
  215.     elsif ($which eq "back") {
  216.     print HTML qq{\n</$$list_type>\n};
  217.     $$depth--;
  218.     }
  219. }
  220.  
  221. sub do_hdr{   # headers
  222.     my($num,$title,$rest,$depth) = @_;
  223.     print HTML qq{<p><hr>\n} if $num == 1;
  224.     process_thing(\$title,"NAME");
  225.     print HTML qq{\n<H$num> };
  226.     print HTML $title; 
  227.     print HTML qq{</H$num>\n};
  228.     do_rest($rest);
  229. }
  230.  
  231. sub do_item{  # list items
  232.     my($title,$rest,$list_type) = @_;
  233.     my $bullet_only = $title eq '*' and $list_type eq 'UL';
  234.     process_thing(\$title,"NAME");
  235.     if ($list_type eq "DL") {
  236.     print HTML qq{\n<DT><STRONG>\n};
  237.     print HTML $title; 
  238.     print HTML qq{\n</STRONG>\n};
  239.     print HTML qq{<DD>\n};
  240.     }
  241.     else {
  242.     print HTML qq{\n<LI>};
  243.     unless ($bullet_only or $list_type eq "OL") {
  244.         print HTML $title,"\n";
  245.     }
  246.     }
  247.     do_rest($rest);
  248. }
  249.  
  250. sub do_rest{   # the rest of the chunk handled here
  251.     my($rest) = @_;
  252.     my(@lines,$p,$q,$line,,@paras,$inpre);
  253.     @paras = split(/\n\n\n*/,$rest);  
  254.     for ($p = 0; $p <= $#paras; $p++) {
  255.     $paras[$p] =~ s/^\n//mg;
  256.     @lines = split(/\n/,$paras[$p]);
  257.         if ($in_html) {  # handle =for html paragraphs
  258.             print HTML $paras[0];
  259.             $in_html = 0;
  260.             next;
  261.         }
  262.     elsif ($lines[0] =~ /^\s+\w*\t.*/) {  # listing or unordered list
  263.         print HTML qq{<UL>};
  264.         foreach $line (@lines) { 
  265.         ($line =~ /^\s+(\w*)\t(.*)/) && (($key,$rem) = ($1,$2));
  266.         print HTML defined($Podnames{$key}) 
  267.                 ?  "<LI>$type$key.html\">$key<\/A>\t$rem</LI>\n" 
  268.                 : "<LI>$line</LI>\n";
  269.         }
  270.         print HTML qq{</UL>\n};
  271.     }
  272.     elsif ($lines[0] =~ /^\s/) {       # preformatted code
  273.         if ($paras[$p] =~/>>|<</) {
  274.         print HTML qq{\n<PRE>\n};
  275.         $inpre=1;
  276.         }
  277.         else {                         # Still cant beat XMP.  Yes, I know 
  278.         print HTML qq{\n<XMP>\n}; # it's been obsoleted... suggestions?
  279.         $inpre = 0;
  280.         }
  281.         while (defined($paras[$p])) {
  282.             @lines = split(/\n/,$paras[$p]);
  283.         foreach $q (@lines) {      # mind your p's and q's here :-)
  284.             if ($paras[$p] =~ />>|<</) {
  285.             if ($inpre) {
  286.                 process_thing(\$q,"HTML");
  287.             }
  288.             else {
  289.                 print HTML qq{\n</XMP>\n};
  290.                 print HTML qq{<PRE>\n};
  291.                 $inpre=1;
  292.                 process_thing(\$q,"HTML");
  293.             }
  294.             }
  295.             1 while $q =~  s/\t+/' 'x (length($&) * 8 - length($`) % 8)/e;
  296.             print HTML  $q,"\n";
  297.         }
  298.         last if $paras[$p+1] !~ /^\s/;
  299.         $p++;
  300.         }
  301.         print HTML ($inpre==1) ? (qq{\n</PRE>\n}) : (qq{\n</XMP>\n});
  302.     }
  303.     else {                             # other text
  304.         @lines = split(/\n/,$paras[$p]);
  305.         foreach $line (@lines) {
  306.                 process_thing(\$line,"HTML");
  307.         print HTML qq{$line\n};
  308.         }
  309.     }
  310.     print HTML qq{<p>};
  311.     }
  312. }
  313.  
  314. sub process_thing{       # process a chunk, order important
  315.     my($thing,$htype) = @_;
  316.     pre_escapes($thing);
  317.     find_refs($thing,$htype);
  318.     post_escapes($thing);
  319. }
  320.  
  321. sub scan_thing{           # scan a chunk for later references
  322.     my($cmd,$title,$pod) = @_;
  323.     $_ = $title;
  324.     s/\n$//;
  325.     s/E<(.*?)>/&$1;/g;
  326.     # remove any formatting information for the headers
  327.     s/[SFCBI]<(.*?)>/$1/g;         
  328.     # the "don't format me" thing
  329.     s/Z<>//g;
  330.     if ($cmd eq "item") {
  331.         /^\*/ and  return;     # skip bullets
  332.         /^\d+\./ and  return;     # skip numbers
  333.         s/(-[a-z]).*/$1/i;
  334.     trim($_);
  335.         return if defined $A->{$pod}->{"Items"}->{$_};
  336.         $A->{$pod}->{"Items"}->{$_} = gensym($pod, $_);
  337.         $A->{$pod}->{"Items"}->{(split(' ',$_))[0]}=$A->{$pod}->{"Items"}->{$_};
  338.         Debug("items", "item $_");
  339.         if (!/^-\w$/ && /([%\$\@\w]+)/ && $1 ne $_ 
  340.             && !defined($A->{$pod}->{"Items"}->{$_}) && ($_ ne $1)) 
  341.         {
  342.             $A->{$pod}->{"Items"}->{$1} = $A->{$pod}->{"Items"}->{$_};
  343.             Debug("items", "item $1 REF TO $_");
  344.         } 
  345.         if ( m{^(tr|y|s|m|q[qwx])/.*[^/]} ) {
  346.             my $pf = $1 . '//';
  347.             $pf .= "/" if $1 eq "tr" || $1 eq "y" || $1 eq "s";
  348.             if ($pf ne $_) {
  349.                 $A->{$pod}->{"Items"}->{$pf} = $A->{$pod}->{"Items"}->{$_};
  350.                 Debug("items", "item $pf REF TO $_");
  351.             }
  352.     }
  353.     }
  354.     elsif ($cmd =~ /^head[12]/) {                
  355.         return if defined($A->{$pod}->{"Headers"}->{$_});
  356.         $A->{$pod}->{"Headers"}->{$_} = gensym($pod, $_);
  357.         Debug("headers", "header $_");
  358.     } 
  359.     else {
  360.         warn "unrecognized header: $cmd" if $Debug;
  361.     } 
  362. }
  363.  
  364.  
  365. sub picrefs { 
  366.     my($char, $bigkey, $lilkey,$htype) = @_;
  367.     my($key,$ref,$podname);
  368.     for $podname ($pod,@inclusions) {
  369.     for $ref ( "Items", "Headers" ) {
  370.         if (defined $A->{$podname}->{$ref}->{$bigkey}) {
  371.         $value = $A->{$podname}->{$ref}->{$key = $bigkey};
  372.         Debug("subs", "bigkey is $bigkey, value is $value\n");
  373.         } 
  374.         elsif (defined $A->{$podname}->{$ref}->{$lilkey}) {
  375.         $value = $A->{$podname}->{$ref}->{$key = $lilkey};
  376.         return "" if $lilkey eq '';
  377.         Debug("subs", "lilkey is $lilkey, value is $value\n");
  378.         } 
  379.     } 
  380.     if (length($key)) {
  381.             ($pod2,$num) = split(/_/,$value,2);
  382.         if ($htype eq "NAME") {  
  383.         return "\n<A NAME=\"".$value."\">\n$bigkey</A>\n"
  384.         }
  385.         else {
  386.         return "\n$type$pod2.html\#".$value."\">$bigkey<\/A>\n";
  387.         }
  388.     } 
  389.     }
  390.     if ($char =~ /[IF]/) {
  391.     return "<EM>$bigkey</EM>";
  392.     } elsif ($char =~ /C/) {
  393.     return "<CODE>$bigkey</CODE>";
  394.     } else {
  395.     return "<STRONG>$bigkey</STRONG>";
  396.     }
  397. } 
  398.  
  399. sub find_refs { 
  400.     my($thing,$htype) = @_;
  401.     my($orig) = $$thing;
  402.     # LREF: a manpage(3f) we don't know about
  403.     for ($$thing) {
  404.     #s:L<([a-zA-Z][^\s\/]+)(\([^\)]+\))>:the I<$1>$2 manpage:g;
  405.         s@(\S+?://\S*[^.,;!?\s])@noremap(qq{<A HREF="$1">$1</A>})@ge;
  406.         s,([a-z0-9_.-]+\@([a-z0-9_-]+\.)+([a-z0-9_-]+)),noremap(qq{<A HREF="MAILTO:$1">$1</A>}),gie;
  407.     s/L<([^>]*)>/lrefs($1,$htype)/ge;
  408.     s/([CIBF])<(\W*?(-?\w*).*?)>/picrefs($1, $2, $3, $htype)/ge;
  409.     s/(S)<([^\/]\W*?(-?\w*).*?)>/picrefs($1, $2, $3, $htype)/ge;
  410.     s/((\w+)\(\))/picrefs("I", $1, $2,$htype)/ge;
  411.     s/([\$\@%](?!&[gl]t)([\w:]+|\W\b))/varrefs($1,$htype)/ge;
  412.     }
  413.     if ($$thing eq $orig && $htype eq "NAME") { 
  414.     $$thing = picrefs("I", $$thing, "", $htype);
  415.     }
  416.  
  417. }
  418.  
  419. sub lrefs {
  420.     my($page, $item) = split(m#/#, $_[0], 2);
  421.     my($htype) = $_[1];
  422.     my($podname);
  423.     my($section) = $page =~ /\((.*)\)/;
  424.     my $selfref;
  425.     if ($page =~ /^[A-Z]/ && $item) {
  426.     $selfref++;
  427.     $item = "$page/$item";
  428.     $page = $pod;
  429.     }  elsif (!$item && $page =~ /[^a-z\-]/ && $page !~ /^\$.$/) {
  430.     $selfref++;
  431.     $item = $page;
  432.     $page = $pod;
  433.     } 
  434.     $item =~ s/\(\)$//;
  435.     if (!$item) {
  436.         if (!defined $section && defined $Podnames{$page}) {
  437.         return "\n$type$page.html\">\nthe <EM>$page</EM> manpage<\/A>\n";
  438.     } else {
  439.         (warn "Bizarre entry $page/$item") if $Debug;
  440.         return "the <EM>$_[0]</EM>  manpage\n";
  441.     } 
  442.     } 
  443.  
  444.     if ($item =~ s/"(.*)"/$1/ || ($item =~ /[^\w\/\-]/ && $item !~ /^\$.$/)) {
  445.     $text = "<EM>$item</EM>";
  446.     $ref = "Headers";
  447.     } else {
  448.     $text = "<EM>$item</EM>";
  449.     $ref = "Items";
  450.     } 
  451.     for $podname ($pod, @inclusions) {
  452.     undef $value;
  453.     if ($ref eq "Items") {
  454.         if (defined($value = $A->{$podname}->{$ref}->{$item})) {
  455.         ($pod2,$num) = split(/_/,$value,2);
  456.         return (($pod eq $pod2) && ($htype eq "NAME"))
  457.             ? "\n<A NAME=\"".$value."\">\n$text</A>\n"
  458.             : "\n$type$pod2.html\#".$value."\">$text<\/A>\n";
  459.             }
  460.         } 
  461.     elsif ($ref eq "Headers") {
  462.         if (defined($value = $A->{$podname}->{$ref}->{$item})) {
  463.         ($pod2,$num) = split(/_/,$value,2);
  464.         return (($pod eq $pod2) && ($htype eq "NAME")) 
  465.             ? "\n<A NAME=\"".$value."\">\n$text</A>\n"
  466.             : "\n$type$pod2.html\#".$value."\">$text<\/A>\n";
  467.             }
  468.     }
  469.     }
  470.     warn "No $ref reference for $item (@_)" if $Debug;
  471.     return $text;
  472. } 
  473.  
  474. sub varrefs {
  475.     my ($var,$htype) = @_;
  476.     for $podname ($pod,@inclusions) {
  477.     if ($value = $A->{$podname}->{"Items"}->{$var}) {
  478.         ($pod2,$num) = split(/_/,$value,2);
  479.         Debug("vars", "way cool -- var ref on $var");
  480.         return (($pod eq $pod2) && ($htype eq "NAME"))  # INHERIT $_, $pod
  481.         ? "\n<A NAME=\"".$value."\">\n$var</A>\n"
  482.         : "\n$type$pod2.html\#".$value."\">$var<\/A>\n";
  483.     }
  484.     }
  485.     Debug( "vars", "bummer, $var not a var");
  486.     return "<STRONG>$var</STRONG>";
  487. } 
  488.  
  489. sub gensym {
  490.     my ($podname, $key) = @_;
  491.     $key =~ s/\s.*//;
  492.     ($key = lc($key)) =~ tr/a-z/_/cs;
  493.     my $name = "${podname}_${key}_0";
  494.     $name =~ s/__/_/g;
  495.     while ($sawsym{$name}++) {
  496.         $name =~ s/_?(\d+)$/'_' . ($1 + 1)/e;
  497.     }
  498.     return $name;
  499. } 
  500.  
  501. sub pre_escapes {  # twiddle these, and stay up late  :-)
  502.     my($thing) = @_;
  503.     for ($$thing) { 
  504.     s/"(.*?)"/``$1''/gs;
  505.     s/&/noremap("&")/ge;
  506.     s/<</noremap("<<")/eg;
  507.     s/([^ESIBLCF])</$1\<\;/g;
  508.     s/E<([^\/][^<>]*)>/\&$1\;/g;              # embedded special
  509.     }
  510. }
  511. sub noremap {   # adding translator for hibit chars soon
  512.     my $hide = $_[0];
  513.     $hide =~ tr/\000-\177/\200-\377/;  
  514.     $hide;
  515. } 
  516.  
  517.  
  518. sub post_escapes {
  519.     my($thing) = @_;
  520.     for ($$thing) {
  521.     s/([^GM])>>/$1\>\;\>\;/g;
  522.     s/([^D][^"MGA])>/$1\>\;/g;
  523.     tr/\200-\377/\000-\177/;
  524.     }
  525. }
  526.  
  527. sub Debug {
  528.     my $level = shift;
  529.     print STDERR @_,"\n" if $Debug{$level};
  530. } 
  531.  
  532. sub dumptable  {
  533.     my $t = shift;
  534.     print STDERR "TABLE DUMP $t\n";
  535.     foreach $k (sort keys %$t) {
  536.     printf STDERR "%-20s <%s>\n", $t->{$k}, $k;
  537.     } 
  538. } 
  539. sub trim {
  540.     for (@_) {
  541.         s/^\s+//;
  542.         s/\s\n?$//;
  543.     }
  544. }
  545. !NO!SUBS!
  546.  
  547. close OUT or die "Can't close $file: $!";
  548. chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
  549. exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
  550.